home *** CD-ROM | disk | FTP | other *** search
/ CD ROM Paradise Collection 4 / CD ROM Paradise Collection 4 1995 Nov.iso / program / swagg_m.zip / GRAPHICS.SWG / 0044_Writing PCX files.pas < prev    next >
Pascal/Delphi Source File  |  1993-11-21  |  12KB  |  405 lines
  1. {
  2. From: WILLIAM PLANKE
  3. Subj: Write PCX example 1/4
  4.  
  5. As I follow this forum, many requests are made for PCX graphics
  6. file routines. Those that are looking for Read_PCX info can
  7. find it on the ZSoft BBS in a wonderful Pascal example: ShowPCX.
  8.  
  9. On the other hand, there is next to zilch out there on how to
  10. Write_PCX files. I know.... I searched and searched and couldn't
  11. find a thing! So with a little brute force  and a few ZSoft
  12. C language snippets <groan>, I got this together:
  13. }
  14.  
  15.  
  16. { =================== TPv6.0  P C X _ W ======================== }
  17.  
  18. {$R-}    {Range checking, turn off when debugged}
  19.  
  20. unit PCX_W;
  21.  
  22. { --------------------- Interface ----------------- }
  23.  
  24. interface
  25.  
  26. type
  27.     Str80 = string [80];
  28.  
  29. procedure Write_PCX  (Name:Str80);
  30.  
  31.  
  32. { ===================== Implementation ============ }
  33.  
  34. implementation
  35.  
  36. uses
  37.     Graph;
  38.  
  39.  
  40. {-------------- Write_PCX --------------}
  41.  
  42. procedure Write_PCX (Name:Str80);
  43.  
  44. const
  45.      RED1   = 0;
  46.      GREEN1 = 1;
  47.      BLUE1  = 2;
  48.  
  49. type
  50.     ArrayPal   = array [0..15, RED1..BLUE1] of byte;
  51.  
  52. const
  53.      MAX_WIDTH  = 4000;    { arbitrary - maximum width (in bytes) of
  54.                              a PCX image }
  55.      INTENSTART =   $5;
  56.      BLUESTART  =  $55;
  57.      GREENSTART =  $A5;
  58.      REDSTART   =  $F5;
  59.  
  60. type
  61.     Pcx_Header = record
  62.     {comments from ZSoft ShowPCX pascal example}
  63.  
  64.         Manufacturer: byte;     { Always 10 for PCX file }
  65.  
  66.         Version: byte;          { 2 - old PCX - no palette (not used
  67.                                       anymore),
  68.                                   3 - no palette,
  69.                                   4 - Microsoft Windows - no palette
  70.                                       (only in old files, new Windows
  71.                                       version uses 3),
  72.                                   5 - with palette }
  73.  
  74.         Encoding: byte;         { 1 is PCX, it is possible that we may
  75.                                   add additional encoding methods in the
  76.                                   future }
  77.  
  78.         Bits_per_pixel: byte;   { Number of bits to represent a pixel
  79.                                   (per plane) - 1, 2, 4, or 8 }
  80.  
  81.         Xmin: integer;          { Image window dimensions (inclusive) }
  82.         Ymin: integer;          { Xmin, Ymin are usually zero (not always)}
  83.         Xmax: integer;
  84.         Ymax: integer;
  85.  
  86.         Hdpi: integer;          { Resolution of image (dots per inch) }
  87.         Vdpi: integer;          { Set to scanner resolution - 300 is
  88.                                   default }
  89.  
  90.         ColorMap: ArrayPal;
  91.                                 { RGB palette data (16 colors or less)
  92.                                   256 color palette is appended to end
  93.                                   of file }
  94.  
  95.         Reserved: byte;         { (used to contain video mode)
  96.                                   now it is ignored - just set to zero }
  97.  
  98.         Nplanes: byte;          { Number of planes }
  99.  
  100.         Bytes_per_line_per_plane: integer;   { Number of bytes to
  101.                                                allocate for a scanline
  102.                                                plane. MUST be an an EVEN
  103.                                                number! Do NOT calculate
  104.                                                from Xmax-Xmin! }
  105.  
  106.         PaletteInfo: integer;   { 1 = black & white or color image,
  107.                                   2 = grayscale image - ignored in PB4,
  108.                                       PB4+ palette must also be set to
  109.                                       shades of gray! }
  110.  
  111.         HscreenSize: integer;   { added for PC Paintbrush IV Plus
  112.                                   ver 1.0,  }
  113.         VscreenSize: integer;   { PC Paintbrush IV ver 1.02 (and later)}
  114.                                 { I know it is tempting to use these
  115.                                   fields to determine what video mode
  116.                                   should be used to display the image
  117.                                   - but it is NOT recommended since the
  118.                                   fields will probably just contain
  119.                                   garbage. It is better to have the
  120.                                   user install for the graphics mode he
  121.                                   wants to use... }
  122.  
  123.         Filler: array [74..127] of byte;     { Just set to zeros }
  124.     end;
  125.  
  126.     Array80    = array [1..80]        of byte;
  127.     ArrayLnImg = array [1..326]       of byte; { 6 extra bytes at
  128.      beginng of line that BGI uses for size info}
  129.     Line_Array = array [0..MAX_WIDTH] of byte;
  130.     ArrayLnPCX = array [1..4]         of Array80;
  131.  
  132. var
  133.    PCXName   : File;
  134.    Header    : Pcx_Header;                 { PCX file header }
  135.    ImgLn     : ArrayLnImg;
  136.    PCXLn     : ArrayLnPCX;
  137.    RedLn,
  138.    BlueLn,
  139.    GreenLn,
  140.    IntenLn   : Array80;
  141.    Img       : pointer;
  142.  
  143.  
  144. {-------------- BuildHeader- -----------}
  145.  
  146. procedure BuildHeader;
  147.  
  148. const
  149.      PALETTEMAP: ArrayPal=
  150.                  {  R    G    B                    }
  151.                 (($00, $00, $00),  {  black        }
  152.                  ($00, $00, $AA),  {  blue         }
  153.                  ($00, $AA, $00),  {  green        }
  154.                  ($00, $AA, $AA),  {  cyan         }
  155.                  ($AA, $00, $00),  {  red          }
  156.                  ($AA, $00, $AA),  {  magenta      }
  157.                  ($AA, $55, $00),  {  brown        }
  158.                  ($AA, $AA, $AA),  {  lightgray    }
  159.                  ($55, $55, $55),  {  darkgray     }
  160.                  ($55, $55, $FF),  {  lightblue    }
  161.                  ($55, $FF, $55),  {  lightgreen   }
  162.                  ($55, $FF, $FF),  {  lightcyan    }
  163.                  ($FF, $55, $55),  {  lightred     }
  164.                  ($FF, $55, $FF),  {  lightmagenta }
  165.                  ($FF, $FF, $55),  {  yellow       }
  166.                  ($FF, $FF, $FF) );{  white        }
  167.  
  168. var
  169.    i : word;
  170.  
  171. begin
  172.      with Header do
  173.           begin
  174.                Manufacturer  := 10;
  175.                Version  := 5;
  176.                Encoding := 1;
  177.                Bits_per_pixel := 1;
  178.                Xmin := 0;
  179.                Ymin := 0;
  180.                Xmax := 639;
  181.                Ymax := 479;
  182.                Hdpi := 640;
  183.                Vdpi := 480;
  184.                ColorMap := PALETTEMAP;
  185.                Reserved := 0;
  186.                Nplanes  := 4; { Red, Green, Blue, Intensity }
  187.                Bytes_per_line_per_plane := 80;
  188.                PaletteInfo := 1;
  189.                HscreenSize := 0;
  190.                VscreenSize := 0;
  191.                for i := 74 to 127 do
  192.                    Filler [i] := 0;
  193.           end;
  194. end;
  195.  
  196.  
  197. {-------------- GetBGIPlane ------------}
  198.  
  199. procedure GetBGIPlane (Start:word; var Plane:Array80);
  200.  
  201. var
  202.    i : word;
  203.  
  204. begin
  205.      for i:= 1 to Header.Bytes_per_line_per_plane do
  206.          Plane [i] := ImgLn [Start +i -1]
  207. end;
  208.  
  209. {-------------- BuildPCXPlane ----------}
  210.  
  211. procedure BuildPCXPlane (Start:word; Plane:Array80);
  212.  
  213. var
  214.    i : word;
  215.  
  216. begin
  217.      for i := 1 to Header.Bytes_per_line_per_plane do
  218.          PCXLn [Start] [i] := Plane [i];
  219. end;
  220.  
  221.  
  222. {-------------- EncPCXLine -------------}
  223.  
  224. procedure EncPCXLine (PlaneLine : word); { Encode a PCX line }
  225.  
  226. var
  227.    This,
  228.    Last,
  229.    RunCount : byte;
  230.    i,
  231.    j        : word;
  232.  
  233.  
  234.   {-------------- EncPut -----------------}
  235.  
  236.   procedure EncPut (Byt, Cnt :byte);
  237.  
  238.   const
  239.        COMPRESS_NUM = $C0;  { this is the upper two bits that
  240.                               indicate a count }
  241.  
  242.   var
  243.      Holder : byte;
  244.  
  245.   begin
  246.   {$I-}
  247.        if (Cnt = 1) and (COMPRESS_NUM <> (COMPRESS_NUM and Byt)) then
  248.           blockwrite (PCXName, Byt,1)          { single occurance }
  249.           {good place for file error handler!}
  250.        else
  251.            begin
  252.                 Holder := (COMPRESS_NUM or Cnt);
  253.                 blockwrite (PCXName, Holder, 1); { number of times the
  254.                                                    following color
  255.                                                    occurs }
  256.                 blockwrite (PCXName, Byt, 1);
  257.            end;
  258.   {$I+}
  259.   end;
  260.  
  261.  
  262. begin
  263.      i := 1;         { used in PCXLn }
  264.      RunCount := 1;
  265.      Last := PCXLn [PlaneLine][i];
  266.      for j := 1 to Header.Bytes_per_line_per_plane -1 do
  267.          begin
  268.               inc (i);
  269.               This := PCXLn [PlaneLine][i];
  270.               if This = Last then
  271.                  begin
  272.                       inc (RunCount);
  273.                       if RunCount = 63 then   { reached PCX run length
  274.                                                 limited max yet? }
  275.                          begin
  276.                               EncPut (Last, RunCount);
  277.                               RunCount := 0;
  278.                          end;
  279.                  end
  280.               else
  281.                   begin
  282.                        if RunCount >= 1 then
  283.                           Encput (Last, RunCount);
  284.                        Last := This;
  285.                        RunCount := 1;
  286.                   end;
  287.          end;
  288.      if RunCount >= 1 then  { any left over ? }
  289.         Encput (Last, RunCount);
  290. end;
  291.  
  292.             { - - -W-R-I-T-E-_-P-C-X- - - - - - - - }
  293.  
  294. const
  295.      XMAX = 639;
  296.      YMAX = 479;
  297.  
  298. var
  299.    i, j, Size : word;
  300.  
  301. begin
  302.      BuildHeader;
  303.      assign     (PCXName,Name);
  304. {$I-}
  305.      rewrite    (PCXName,1);
  306.      blockwrite (PCXName,Header,sizeof (Header));
  307.      {good place for file error handler!}
  308. {$I+}
  309.      setviewport (0,0,XMAX,YMAX, ClipOn);
  310.      Size := imagesize (0,0,XMAX,0); { size of a single row }
  311.      getmem (Img,Size);
  312.  
  313.      for i := 0 to YMAX do
  314.          begin
  315.               getimage (0,i,XMAX,i,Img^);  { Grab 1 line from the
  316.                                              screen store in Img
  317.                                              buffer  }
  318.               move (Img^,ImgLn,Size {326});
  319.  
  320.  
  321.               GetBGIPlane (INTENSTART, IntenLn);
  322.               GetBGIPlane (BLUESTART,  BlueLn );
  323.               GetBGIPlane (GREENSTART, GreenLn);
  324.               GetBGIPlane (REDSTART,   RedLn  );
  325.               BuildPCXPlane (1, RedLn  );
  326.               BuildPCXPlane (2, GreenLn);
  327.               BuildPCXPlane (3, BlueLn );
  328.               BuildPCXPlane (4, IntenLn); { 320 bytes/line
  329.                                             uncompressed }
  330.               for j := 1 to Header.NPlanes do
  331.  
  332.                   EncPCXLine (j);
  333.          end;
  334.      freemem (Img,Size);           (* Release the memory        *)
  335. {$I-}
  336.      close (PCXName);              (* Save the Image            *)
  337. {$I+}
  338. end;
  339.  
  340. end {PCX.TPU} .
  341.  
  342.  
  343. { -----------------------Test Program -------------------------- }
  344.  
  345. program WritePCX;
  346.  
  347. uses
  348.     Graph, PCX_W;
  349.  
  350. {-------------- DrawHorizBars ----------}
  351.  
  352. procedure DrawHorizBars;
  353.  
  354. var
  355.    i, Color : word;
  356.  
  357. begin
  358.      cleardevice;
  359.      Color := 15;
  360.      for i := 0 to 15 do
  361.          begin
  362.               setfillstyle (solidfill,Color);
  363.               bar (0,i*30,639,i*30+30);       { 16*30 = 480 }
  364.               dec (Color);
  365.          end;
  366. end;
  367.  
  368. {-------------- Main -------------------}
  369.  
  370. var
  371.    NameW : Str80;
  372.    Gd,
  373.    Gm    : integer;
  374.  
  375. begin
  376.      writeln;
  377.      if (ParamCount = 0) then           { no DOS command line
  378.                                           parameters }
  379.         begin
  380.              write ('Enter name of PCX picture file to write: ');
  381.              readln (NameW);
  382.              writeln;
  383.         end
  384.      else
  385.          begin
  386.               NameW := paramstr (1);  { get filename from DOS
  387.                                         command line }
  388.          end;
  389.  
  390.      if (Pos ('.', NameW) = 0) then   { make sure the filename
  391.                                         has PCX extension }
  392.         NameW := Concat (NameW, '.pcx');
  393.  
  394.      Gd:=VGA;
  395.      Gm:=VGAhi; {640x480, 16 colors}
  396.      initgraph (Gd,Gm,'..\bgi');  { path to your EGAVGA.BGI }
  397.  
  398.      DrawHorizBars;
  399.  
  400.      readln;
  401.      Write_PCX (NameW); { PCX_W.TPU }
  402.      closegraph;                    { Close graphics    }
  403.      textmode (co80);               { back to text mode }
  404. end.  { Write_PCX }
  405.